home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HyperLib 1997 Winter - Disc 1
/
HYPERLIB-1997-Winter-CD1.ISO.7z
/
HYPERLIB-1997-Winter-CD1.ISO
/
オンラインウェア
/
PRG
/
ICProgKit 1.3.sit
/
ICProgKit1.3
/
Goodies
/
ICeTEe
/
ICeTEe.p
next >
Wrap
Text File
|
1996-07-20
|
10KB
|
400 lines
unit ICeTEe;
interface
procedure Main;
implementation
uses
Processes, SysEqu, Notification, Traps,
ShowInit75,
ICTypes, ICCAPI;
const
MenuFlash = $A24;
ToolScratch = $9CE;
const
kCreator = 'ICTE';
const
(* EXCL *)
rExclusions = 128;
(* ICN# *)
rICTEIcon = 128;
rFailedIcon = 129;
(* STR# *)
rErrorStrings = 128;
strMiscErr = 1;
strNoCMErr = 2;
strNoICErr = 3;
strInsufficientICErr = 4;
strNoMemoryErr = 5;
strCantFindHelperErr = 6;
strNoHelperErr = 7;
strNoURLErr = 8;
strCantHackIt = 9;
const
noCMErr = -6660;
type
exArray = array[1..1000] of OSType;
exPtr = ^exArray;
exHandle = ^exPtr;
icteGlobals = record
signature: OSType;
version: NumVersion;
exclusions: exHandle;
errors: Handle;
old_teclick: ProcPtr;
end;
icteGlobalsPtr = ^icteGlobals;
icteGlobalsPtrPtr = ^icteGlobalsPtr;
function GetIndStrH (h: handle; index: integer): str255;
(* Stolen directly from PNL's MyStrH unit *)
var
count, i: integer;
s: str255;
ps: longInt;
begin
count := integerPtr(h^)^;
if (1 <= index) and (index <= count) then begin
ps := SizeOf(integer);
for i := 1 to index - 1 do
ps := ps + BAND(ptr(ord(h^) + ps)^, $FF) + 1;
BlockMove(ptr(ord(h^) + ps), @s, BAND(ptr(ord(h^) + ps)^, $FF) + 1);
end
else begin
s := '';
end;
GetIndStrH := s;
end;
function DecStr (l: longint): Str32;
var
tmp: Str255;
begin
NumToString(l, tmp);
DecStr := tmp;
end; (* DecStr *)
function GetMyGlobals: icteGlobalsPtr;
begin
GetMyGlobals := icteGlobalsPtrPtr(@Main)^;
end; (* GetMyGlobals *)
procedure SetMyGlobals (globals: icteGlobalsPtr);
var
tmp: icteGlobalsPtrPtr;
begin
tmp := icteGlobalsPtrPtr(@Main);
tmp^ := globals;
end; (* SetMyGlobals *)
function CurrentProcessExcluded: boolean;
var
PSN: ProcessSerialNumber;
info: ProcessInfoRec;
exclusions: exHandle;
i: integer;
begin
PSN.highLongOfPSN := 0;
PSN.lowLongOfPSN := kCurrentProcess;
info.processInfoLength := sizeof(ProcessInfoRec);
info.processName := nil;
info.processAppSpec := nil;
if GetProcessInformation(PSN, info) = noErr then begin
exclusions := GetMyGlobals^.exclusions;
CurrentProcessExcluded := false;
for i := 1 to GetHandleSize(Handle(exclusions)) div 4 do begin
if exclusions^^[i] = info.processSignature then begin
CurrentProcessExcluded := true;
leave;
end; (* if *)
end; (* for *)
end
else begin
CurrentProcessExcluded := true;
end; (* if *)
end; (* CurrentProcessExcluded *)
function HaveComponentManager: boolean;
var
response: longint;
begin
HaveComponentManager := (Gestalt(gestaltComponentMgr, response) = noErr);
end; (* HaveComponentManager *)
function DoCommandClick (teh: TEHandle; selStart, selEnd: longint): ICError;
var
inst: ComponentInstance;
err: ICError;
err2: ICError;
text: Handle;
s: signedByte;
rgn: RgnHandle;
i: integer;
junklong: longint;
hint, at: Str31;
urlh: Handle;
tmpSelStart, tmpSelEnd: longint;
begin
if HaveComponentManager then begin
err := ICCStart(inst, kCreator);
end
else begin
err := noCMErr;
end; (* if *)
if err = noErr then begin
err := ICCFindConfigFile(inst, 0, nil);
if err = noErr then begin
text := Handle(TEGetText(teh));
s := HGetState(text);
HLock(text);
urlh := NewHandle(0);
hint := 'mailto';
tmpSelStart := selStart;
tmpSelEnd := selEnd;
err := ICCParseURL(inst, hint, text^, GetHandleSize(text), tmpSelStart, tmpSelEnd, urlh);
if err = noErr then begin
hint := '';
at := '@';
if Munger(urlh, 0, @at[1], length(at), nil, 0) >= 0 then begin
hint := 'mailto';
end;
err := ICCLaunchURL(inst, hint, text^, GetHandleSize(text), selStart, selEnd);
end;
DisposeHandle(urlh);
TESetSelect(selStart, selEnd, teh);
if err = noErr then begin
for i := 1 to integerPtr(MenuFlash)^ do begin
Delay(5, junklong);
TEDeactivate(teh);
Delay(5, junklong);
TEActivate(teh);
end; (* for *)
(* leave the URL selected *)
end; (* if *)
HSetState(text, s);
end; (* if *)
err2 := ICCStop(inst);
if err = noErr then begin
err := err2;
end; (* if *)
end; (* if *)
DoCommandClick := err;
end; (* DoCommandClick *)
procedure MyNMResponseProc (nm: NMRecPtr);
var
ozone: THz;
strh: Handle;
junk: OSErr;
begin
junk := NMRemove(nm);
ozone := GetZone;
SetZone(SystemZone);
strh := RecoverHandle(Ptr(nm^.nmStr));
if strh <> nil then begin
DisposeHandle(strh);
end; (* if *)
DisposePtr(Ptr(nm));
SetZone(ozone);
end; (* MyNMResponseProc *)
procedure MyTEClick (teh: TEHandle; old_selStart, old_selEnd: integer);
var
err: ICError;
message: Str255;
nm: NMRecPtr;
strindex: integer;
strh: StringHandle;
begin
if not CurrentProcessExcluded then begin
if not ((old_selStart <= teh^^.selStart) and (teh^^.selStart <= old_selEnd) and (old_selStart <= teh^^.selEnd) and (teh^^.selEnd <= old_selEnd)) then begin
old_selStart := teh^^.selStart;
old_selEnd := teh^^.selEnd;
end; (* if *)
err := DoCommandClick(teh, old_selStart, old_selEnd);
if err <> noErr then begin
(* can't case on the error codes because MPW Pascal does not case on longints properly *)
if err = badComponentInstance then begin
strindex := strNoICErr;
end
else if err = noCMErr then begin
strindex := strNoCMErr;
end
else if err = badComponentSelector then begin
strindex := strInsufficientICErr;
end
else if err = memFullErr then begin
strindex := strNoMemoryErr;
end
else if err = afpItemNotFound then begin
strindex := strCantFindHelperErr;
end
else if err = icPrefNotFoundErr then begin
strindex := strNoHelperErr;
end
else if err = icNoURLErr then begin
strindex := strNoURLErr;
end
else if err = noPortErr then begin
strindex := strCantHackIt;
end
else begin
strindex := strMiscErr;
end; (* if *)
message := GetIndStrH(GetMyGlobals^.errors, strindex);
if message <> '' then begin
strindex := Pos('^0', message);
if strindex <> 0 then begin
Delete(message, strindex, 2);
Insert(DecStr(err), message, strindex);
end; (* if *)
strh := NewString(message);
HLock(Handle(strh));
nm := NMRecPtr(NewPtrSysClear(sizeof(NMRec)));
if nm <> nil then begin
nm^.qType := ord(nmType);
nm^.nmMark := 0;
nm^.nmIcon := nil;
nm^.nmSound := nil;
nm^.nmStr := strh^;
nm^.nmResp := @MyNMResponseProc;
err := NMInstall(nm);
end
else begin
SysBeep(10);
end; (* if *)
end; (* if *)
end; (* if *)
end; (* if *)
end; (* MyTEClick *)
procedure CallTEClick (pt: Point; fExtend: boolean; teh: TEHandle; proc: ProcPtr);
inline
$205F, (* move.l (a7)+,a0 ; pop proc address *)
$4E90; (* jsr (a0) ; call proc *)
procedure InlinePushAll;
inline
$48E7, $FFFC;
procedure InlinePopAll;
inline
$4CDF, $3FFF;
procedure PascalTEClickPatch (pt: Point; fExtend: boolean; teh: TEHandle);
var
old_selStart, old_selEnd: integer;
globals: icteGlobalsPtr;
ozone: THz;
command_key: boolean;
km: KeyMap;
begin
InlinePushAll;
globals := GetMyGlobals;
old_selStart := teh^^.selStart;
old_selEnd := teh^^.selEnd;
GetKeys(km);
command_key := km[55];
CallTEClick(pt, fExtend, teh, globals^.old_teclick);
if command_key and (GetHandleSize(Handle(TEGetText(teh))) > 0) then begin
ozone := GetZone;
SetZone(SystemZone);
MyTEClick(teh, old_selStart, old_selEnd);
SetZone(ozone);
end; (* if *)
InlinePopAll;
end; (* PascalTEClickPatch *)
function MyGestalt (selector: OSType; var response: longint): OSErr;
var
globals: icteGlobalsPtr;
begin
globals := GetMyGlobals;
response := longint(globals);
MyGestalt := noErr;
end; (* MyGestalt *)
procedure Main;
var
ozone: THz;
err: OSErr;
err2: OSErr;
response: longint;
globals: icteGlobalsPtr;
exclusions: Handle;
errors: Handle;
vers: VersRecHndl;
begin
(* Debugger; *)
(* detach our resource *)
DetachResource(RecoverHandle(Ptr(longintPtr(ToolScratch)^)));
ShowIcon7(rICTEIcon, false);
ozone := GetZone;
SetZone(SystemZone);
(* check for System 7 *)
err := noErr;
if (Gestalt(gestaltSystemVersion, response) <> noErr) | (response < $700) then begin
err := unimpErr;
end; (* if *)
(* create the globals *)
if err = noErr then begin
globals := icteGlobalsPtr(NewPtrSysClear(sizeof(icteGlobals)));
err := MemError;
end; (* if *)
if err = noErr then begin
(* install globals *)
SetMyGlobals(globals);
globals := GetMyGlobals;
(* init globals *)
globals^.signature := kCreator;
vers := VersRecHndl(Get1Resource('vers', 1));
if vers <> nil then begin
globals^.version := vers^^.numericVersion;
end; (* if *)
exclusions := Get1Resource('EXCL', rExclusions);
err := HandToHand(exclusions);
globals^.exclusions := exHandle(exclusions);
errors := Get1Resource('STR#', rErrorStrings);
err2 := HandToHand(errors);
globals^.errors := errors;
if err = noErr then begin
err := err2;
end; (* if *)
end; (* if *)
(* register gestalt *)
if err = noErr then begin
err := NewGestalt(kCreator, @MyGestalt);
end; (* if *)
if err = noErr then begin
(* install our patch *)
globals^.old_teclick := ProcPtr(NGetTrapAddress(_TEClick, ToolTrap));
NSetTrapAddress(longint(@PascalTEClickPatch), _TEClick, ToolTrap);
end; (* if *)
(* if we got an error then we bleed memory all over the place, this is not an accident *)
(* how many copies of the init can you reasonably fail to install??? *)
SetZone(ozone);
if err = noErr then begin
ShowIcon7(rICTEIcon, true);
end
else begin
ShowIcon7(rFailedIcon, true);
end; (* if *)
end; (* Main *)
end. (* ICeTEe *)
selStartX, selEndX: longint;
selStartX := selStart;
selEndX := selEnd;